home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmputil.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  8.0 KB  |  265 lines
  1. ;;; CMPUTIL  Miscellaneous Functions.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (export '(*suppress-compiler-warnings*
  25.           *suppress-compiler-notes*
  26.           *compiler-break-enable*))
  27.  
  28. (defmacro safe-compile (&rest forms) `(when *safe-compile* ,@forms))
  29.  
  30. (defvar *current-form* '|compiler preprocess|)
  31. (defvar *first-error* t)
  32. (defvar *error-count* 0)
  33.  
  34. (defconstant *cmperr-tag* (cons nil nil))
  35.  
  36. (defun cmperr (string &rest args &aux (*print-case* :upcase))
  37.   (print-current-form)
  38.   (format t "~&;;; ")
  39.   (apply #'format t string args)
  40.   (incf *error-count*)
  41.   (throw *cmperr-tag* '*cmperr-tag*))
  42.  
  43. (defmacro cmpck (condition string &rest args)
  44.   `(if ,condition (cmperr ,string ,@args)))
  45.  
  46. (defun too-many-args (name upper-bound n &aux (*print-case* :upcase))
  47.   (print-current-form)
  48.   (format t
  49.           ";;; ~S requires at most ~R argument~:p, ~
  50.           but ~R ~:*~[were~;was~:;were~] supplied.~%"
  51.           name
  52.           upper-bound
  53.           n)
  54.   (incf *error-count*)
  55.   (throw *cmperr-tag* '*cmperr-tag*))
  56.  
  57. (defun too-few-args (name lower-bound n &aux (*print-case* :upcase))
  58.   (print-current-form)
  59.   (format t
  60.           ";;; ~S requires at least ~R argument~:p, ~
  61.           but only ~R ~:*~[were~;was~:;were~] supplied.~%"
  62.           name
  63.           lower-bound
  64.           n)
  65.   (incf *error-count*)
  66.   (throw *cmperr-tag* '*cmperr-tag*))
  67.  
  68. (defvar *suppress-compiler-warnings* nil)
  69.  
  70. (defun cmpwarn (string &rest args &aux (*print-case* :upcase))
  71.   (unless *suppress-compiler-warnings*
  72.     (print-current-form)
  73.     (format t ";; Warning: ")
  74.     (apply #'format t string args)
  75.     (terpri))
  76.   nil)
  77.  
  78. (defvar *suppress-compiler-notes* nil)
  79.  
  80. (defun cmpnote (string &rest args &aux (*print-case* :upcase))
  81.   (unless *suppress-compiler-notes* 
  82.     (terpri)
  83.     (format t ";; Note: ")
  84.     (apply #'format t string args))
  85.   nil)
  86.  
  87. (defun print-current-form ()
  88.   (when *first-error*
  89.         (setq *first-error* nil)
  90.         (fresh-line)
  91.         (cond
  92.          ((and (consp *current-form*)
  93.                (eq (car *current-form*) 'si:|#,|))
  94.           (format t "; #,~s is being compiled.~%" (cdr *current-form*)))
  95.          (t
  96.           (let ((*print-length* 2)
  97.                 (*print-level* 2))
  98.                (format t "; ~s is being compiled.~%" *current-form*)))))
  99.   nil)
  100.  
  101. (defun undefined-variable (sym &aux (*print-case* :upcase))
  102.   (print-current-form)
  103.   (format t
  104.           ";; The variable ~s is undefined.~%~
  105.            ;; The compiler will assume this variable is a global.~%"
  106.           sym)
  107.   nil)
  108.  
  109. (defun baboon (&aux (*print-case* :upcase))
  110.   (print-current-form)
  111.   (format t ";;; A bug was found in the compiler.  Contact Taiichi.~%")
  112.   (incf *error-count*)
  113.   (break)
  114. ;  (throw *cmperr-tag* '*cmperr-tag*)
  115. )
  116.  
  117. ;;; Internal Macros with type declarations
  118.  
  119. (defmacro dolist* ((v l &optional (val nil)) . body)
  120.   (let ((temp (gensym)))
  121.   `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp)))
  122.     ((endp ,temp) ,val)
  123.     (declare (object ,v))
  124.     ,@body)))
  125.  
  126. (defmacro dolist** ((v l &optional (val nil)) . body)
  127.   (let ((temp (gensym)))
  128.   `(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp)))
  129.     ((endp ,temp) ,val)
  130.     (declare (object ,temp ,v))
  131.     ,@body)))
  132.  
  133. (defmacro dotimes* ((v n &optional (val nil)) . body)
  134.   (let ((temp (gensym)))
  135.    `(do* ((,temp ,n) (,v 0 (1+ ,v)))
  136.      ((>= ,v ,temp) ,val)
  137.      (declare (fixnum ,v))
  138.      ,@body)))
  139.  
  140. (defmacro dotimes** ((v n &optional (val nil)) . body)
  141.   (let ((temp (gensym)))
  142.    `(do* ((,temp ,n) (,v 0 (1+ ,v)))
  143.      ((>= ,v ,temp) ,val)
  144.      (declare (fixnum ,temp ,v))
  145.      ,@body)))
  146.  
  147. (defun cmp-eval (form)
  148.   (let ((x (multiple-value-list (cmp-toplevel-eval `(eval ',form)))))
  149.     (if (car x)
  150.         (let ((*print-case* :upcase))
  151.           (incf *error-count*)
  152.           (print-current-form)
  153.           (format t
  154.                   ";;; The form ~s was not evaluated successfully.~%~
  155.                   ;;; You are recommended to compile again.~%"
  156.                   form)
  157.           nil)
  158.         (values-list (cdr x)))))
  159.  
  160.  
  161. ;(si::putprop 'setf 'c1setf 'c1special)
  162.  
  163. ;;The PLACE may be a local macro, so we must take care to expand it
  164. ;;before trying to call the macro form of setf, or an error will
  165.  
  166. ;(defun c1setf (args &aux fd)
  167. ;  (cond ((and
  168. ;       (consp (car args))
  169. ;       (symbolp (caar args))
  170. ;       (setq fd (cmp-macro-function (caar args))))
  171. ;     (c1expr `(setf ,(cmp-expand-macro fd (caar args) (cdar args))
  172. ;            ,@ (cdr args))))
  173. ;    (t       
  174. ;         (c1expr (cmp-expand-macro (macro-function 'setf)
  175. ;                   'setf
  176. ;                   args)))))
  177.  
  178. (defun cmp-macroexpand (form &aux env)
  179.   ;;Obtain the local macro environment for expansion.
  180.   (dolist (v *funs*)
  181.       (if (consp v) (push (list (car v) 'macro (cadr v)) env)))
  182.   (if env (setq env (list nil (nreverse env) nil)))
  183.   (let ((x (multiple-value-list
  184.          (cmp-toplevel-eval `(macroexpand ',form ',env)))))
  185.     (if (car x)
  186.         (let ((*print-case* :upcase))
  187.           (incf *error-count*)
  188.           (print-current-form)
  189.           (format t
  190.                   ";;; The macro form ~s was not expanded successfully.~%"
  191.                   form)
  192.           `(error "Macro-expansion of ~s failed at compile time." ',form))
  193.         (cadr x))))
  194.  
  195. (defun cmp-macroexpand-1 (form &aux env)
  196.   (dolist (v *funs*)
  197.       (if (consp v) (push (list (car v) 'macro (cadr v)) env))) 
  198.   (let ((x (multiple-value-list (cmp-toplevel-eval `(macroexpand-1 ',form
  199.                                    ',env)))))
  200.     (if (car x)
  201.         (let ((*print-case* :upcase))
  202.           (incf *error-count*)
  203.           (print-current-form)
  204.           (format t
  205.                   ";;; The macro form ~s was not expanded successfully.~%"
  206.                   form)
  207.           `(error "Macro-expansion of ~s failed at compile time." ',form))
  208.         (cadr x))))
  209.  
  210. (defun cmp-expand-macro (fd fname args &aux env)
  211.   (dolist (v *funs*)
  212.       (if (consp v) (push (list (car v) 'macro (cadr v)) env)))
  213.   (and *record-call-info* (add-macro-callee fname))
  214.   (if env (setq env (list nil (nreverse env) nil)))
  215.   (let ((x (multiple-value-list
  216.             (cmp-toplevel-eval
  217.              `(funcall *macroexpand-hook* ',fd ',(cons fname args) ',env)))))
  218.     (if (car x)
  219.         (let ((*print-case* :upcase))
  220.           (incf *error-count*)
  221.           (print-current-form)
  222.           (format t
  223.             ";;; The macro form (~s ...) was not expanded successfully.~%"
  224.             fname)
  225.           `(error "Macro-expansion of ~s failed at compile time."
  226.                   ',(cons fname args)))
  227.         (cadr x))))
  228.  
  229. (defvar *compiler-break-enable* nil)
  230.  
  231. (defun cmp-toplevel-eval (form)
  232.    (let* ((si::*ihs-base* si::*ihs-top*)
  233.           (si::*ihs-top* (1- (si::ihs-top)))
  234.           (*break-enable* *compiler-break-enable*)
  235.           (si::*break-hidden-packages*
  236.            (cons (find-package 'compiler)
  237.                  si::*break-hidden-packages*)))
  238.          (si:error-set form)))
  239.  
  240. (dolist (v '(si::cdefn lfun inline-safe inline-unsafe
  241.                inline-always c1conditional c2 c1 c1+ co1
  242.                si::structure-access co1special
  243.                top-level-macro t3 t2 t1 package-operation))
  244.        (si::putprop v t 'compiler-prop ))
  245.  
  246. (defun  compiler-def-hook (symbol code) symbol code nil)
  247.  
  248. (defun compiler-clear-compiler-properties (symbol code)
  249.   code
  250.   (let ((v (symbol-plist symbol)) w)
  251.     (tagbody
  252.       top
  253.       (setq w (car v))
  254.       (cond ((and (symbolp w)
  255.           (get w 'compiler-prop))
  256.  
  257.          (setq v (cddr v))
  258.          (remprop symbol w))
  259.         (t (setq v (cddr v))))
  260.       (or (null v) (go top)))
  261.     (compiler-def-hook symbol code)
  262.     ))
  263.  
  264. ;hi
  265.